package Flap::Template::Parser;
use Flap qw/-b Flap::Object -m -s -w/;

use constant CONFIG => {
    CACHE_SIZE => 100,
    MARKUP     => [qw/[% - - %]/],
    STAT_TTL   => 0,
    STRICT     => 0,
    WARNINGS   => 0,
};

our %PAIR = qw/( ) < > [ ] { }/;
__PACKAGE__->_mk_accessors_(qw/error/);

sub compile {
    my $self = shift;
    my $sr = ref $_[0] ? shift : do{ \(my $s = shift) };
    my $st = {pos => 0, sub => ''};
    
    $self->{error} = undef;
    if(!$self->_compile($sr, $st)){
        $self->{error} = $st->{error} || 'Syntax error';
        if((my $s = substr($$sr, $st->{pos}, (pos($$sr) || length($$sr)) - $st->{pos})) ne ''){
            $self->{error} .= " near `$s`";
        }
        return undef;
    }
    if(my $pos = pos($$sr)){
        $st->{src} = substr($$sr, 0, $pos);
        substr($$sr, 0, $pos) = '';
    }
#print "$st->{src} => $st->{sub}\n";
    if(!($st->{code} = eval 'sub{ '.($st->{var} ? $self->{pragma} : '').$st->{sub}.' }')){
        ($self->{error} = $@) =~ s/at \(eval \d+\)/near "$st->{src}"/;
        return undef;
    }
    delete $st->{pos};
    $st;
}

sub _compile {
    my($self, $sr, $st, $q) = @_;
    
    while(1){
        my $pos = pos($$sr) || 0;
        $$sr =~ /\G([\s!]*)(
            ([A-Za-z_]\w*)([(.[]|\s*(=>|[!=]~\s*(s\W|tr\W)|[%*+\-\/_]?=(?![=~])))?
            |(["\(\/\[]|(?:[%@]|\$\#)?{)
            |'(?:\\.|[^'])*'
            |[+\-]?\d+(?:\.\d+)?
            |\$[0-9ab_]\b
        )/gcx || last;
        $st->{pos} = $pos if !$q;
        $st->{sub} .= $1;
        if($3){
            if($5){ # '=>' or set
                $st->{sub} .= ($5 eq '=>') ? ($q ? $2 : return) : (
                    '$_[0]->{'.(substr($3, 0, 1) le 'Z' ? 'our' : 'my')."}{$3}".
                    ($5 eq '_=' ? ' .=' : $4)
                );
                $6 ? ($self->_compile_regexp($sr, $st, $6) || return) : next;
            }elsif($4 && $4 eq '('){ # [% join(...
                $st->{sub} .= "$3(";
                $self->_compile($sr, $st, ')') || return;
                $st->{sub} .= ')';
            }else{ # [% foo.bar or foo[1] or foo[bar]
                $st->{var}++;
                pos($$sr)-- if $4;
                $self->_compile_var($sr, $st, $3) || return;
            }
        }elsif($7){
            if($7 eq '"'){
                $self->_compile_qq($sr, $st) || return;
            }elsif($7 eq '/'){
                $st->{sub} .= '/';
                $self->_compile_regexp($sr, $st, $7) || return;
            }else{
                $st->{sub} .= $7;
                my $q = $PAIR{$7} || '}';
                $self->_compile($sr, $st, $q) || return;
                $st->{sub} .= $q;
            }
        }else{
            $st->{sub} .= $2;
        }
        
        my $op = $self->_compile_op($sr, $st, $q);
        return if !defined($op) || !$q && ($op eq ',' || $op eq '=>');
        next if $op || ($q && $q eq ')' && substr($st->{sub}, -1) eq '}'); # grep({ /./ } 1 .. 3)
        last;
    }
    if($q){
        return if $$sr !~ /\G(\s*)\Q$q\E/gc && ($st->{error} = "Missing right bracket '$q'");
        $st->{sub} .= $1 if $1;
    }else{
        return if !pos($$sr);
    }
    
    1;
}

sub _compile_op {
    my($self, $sr, $st) = @_;
    
    $$sr =~ /\G(\s*)(
        [%+,\-\/:?_]|\*\*?|\.\.
        |&&|\|\|
        |\b(?:eq|[ngl]e|[gl]t|x(?:or)?)\b
        |[=!]~\s*(\/|m\W)
        |=[=>]|!=|[<>]=?
    )(\s*)/gcx || return '';
    $st->{sub} .= $1.($2 eq '_' ? '.' : $2).$4;
    return $2 if !$3;
    $self->_compile_regexp($sr, $st, $3) || return;
    $self->_compile_op($sr, $st);
}

sub _compile_qq {
    my($self, $sr, $st) = @_;
    
    $st->{sub} .= '"';
    while($$sr =~ /\G((?:\\.|[^"\$@])+|\${|.)/gc){
        if($1 eq '${'){
            $st->{sub} .= '".' if $st->{sub} !~ s/"\z//;
            $self->_compile($sr, $st, '}') || return;
            $st->{sub} .= '."';
        }else{
            $st->{sub} .= ($1 eq '$' || $1 eq '@' ? '\\' : '').$1;
            if($1 eq '"'){
                $st->{sub} =~ s/\.""\z//;
                return 1;
            }
        }
    }
    $st->{error} = q{Can't find string terminator '"' anywhere};
    return;
}

sub _compile_regexp {
    my($self, $sr, $st, $mstr) = @_;
    
    my $q = chop $mstr;
    my $e = $PAIR{$q} || $q;
    while($$sr =~ /\G((?:\\.|[^\Q$e\E\$])+|\${?|.)/gc){
        if($1 eq '${'){
            $st->{sub} .= '(??{ ';
            $self->_compile($sr, $st, '}') || return;
            $st->{sub} .= ' })';
        }else{
            $st->{sub} .= $1;
            if($1 eq $e){
                if($mstr && $mstr ne 'm'){ #s or tr
                    if($e ne $q){
                        $$sr =~ /\G\Q$q\E/gc || return;
                        $st->{sub} .= $q;
                    }
                    $mstr = undef;
                    next;
                }
                $st->{sub} .= $1 if $$sr =~ /\G([gimosx]*\s*)/gc;
                return 1;
            }
        }
    }
    return;
}

sub _compile_var {
    my($self, $sr, $st, $n) = @_;
    
    $st->{sub} .= "\$_[0]->var('$n'";
    while($$sr =~ /\G(?:\.([A-Za-z_]\w*)(\()?|(\[))/gc){
        if($1){
            $st->{sub} .= ", ['.', '$1'";
            if($2){
                $self->_compile($sr, my $_st = {sub => ''}, ')') || return;
                $st->{sub} .= $_st->{var} ? ", sub{ [$_st->{sub}] }" : ", [$_st->{sub}]";
            }
        }else{
            $st->{sub} .= ", ['[', ";
            $self->_compile($sr, my $_st = {sub => ''}, ']') || return;
            return if $_st->{sub} !~ /\S/;
            $st->{sub} .= $_st->{var} ? "sub{ $_st->{sub} }" : $_st->{sub};
        }
        $st->{sub} .= ']';
    }
    $st->{sub} .= ')';
    1;
}

sub create_directive {
    my($self, $sr, $bd, $ed, $id, $ln) = @_;
    
    my $src = substr($$sr, $bd->[1], $ed->[0] - $bd->[1]);
    $src =~ s/^\s+//  || $self->raise(qq{No white space after "$bd->[2]"});
    $src =~ s/\s+\z// || $self->raise(qq{No white space before "$ed->[2]"});
    
    my $d = {id => $id, ln => $ln, src => "$bd->[2] $src $ed->[2]"};
    my $D = $self->project->Template->Directive;
    my $n;
    if($src =~ /^([A-Z])([A-Z]+)(\s+|\z)/ && $D->can($n = $1.lc($2))){
        substr($src, 0, length($1.$2.$3)) = '';
    }else{
        $n = 'GET';
    }
    $D->$n->new($d, \$src, $self);
}

sub create_document {
    my $self = shift;
    return $self->_create_document(@_) if ref($_[0]) eq 'SCALAR' || !$self->{CACHE_SIZE};
    my $loc = shift || die 'No location';
    
    my $path = ($loc->[0] || die 'No base dir').($loc->[1] || die 'No src');
    my $k = join('.', $path, @{$self->{MARKUP}}, $self->{STRICT}, $self->{WARNINGS});
    my $cache = $self->{cache}{$k};
    my($at, $mt);
    return ++$cache->[0] && $cache->[1] if $cache && (
        !$self->{STAT_TTL}
     || ($cache->[2] + $self->{STAT_TTL}) >= ($at = time)
     || ($cache->[2] = $at) && ($mt = (stat $path)[9]) == $cache->[3]
    );
    
    $self->reduce_cache if !$cache && keys %{$self->{cache}} >= $self->{CACHE_SIZE};
    my $doc = $self->_create_document($loc);
    $cache = $self->{cache}{$k} = [1, $doc];
    @$cache[2, 3] = ($at || time, $mt || (stat $path)[9]) if $self->{STAT_TTL};
    $doc;
}

sub _create_document {
    my $self = shift;
    my $doc = {};
    
    if(ref($_[0]) eq 'SCALAR'){
        $doc->{body} = $self->parse(shift);
    }else{
        my $loc = $doc->{location} = shift;
        my $path = ($loc->[0] || die 'No base dir').($loc->[1] || die 'No src');
        $self->OS->cat(my $s, '<', $path) || die "$!($path)";
        $doc->{body} = $self->parse(\$s, $path);
    }
    
    $doc->{strict} = 1 if $self->{STRICT};
    $doc->{warnings} = 1 if $self->{WARNINGS};
    $self->project->Template->Document->new($doc);
}

sub new {
    my $class = shift;
    bless {%{$class->CONFIG}, cache => {}, %{shift || {}}}, $class;
}

sub open {
    my $self = shift;
    $self->project->Template->new($self, $self->create_document(@_));
}

sub parse {
    my($self, $sr) = (shift, shift);
    local $self->{path} = shift;
    local $self->{ln} = 1;
    local $self->{stack} = [];
    local $self->{pragma} = join('', map{ $self->{uc($_)} ? '' : "no $_; " } qw/strict warnings/);
    
    my $m = $self->{MARKUP};
    my $reg = qr/([ \t]*)(\Q$m->[0]\E)(\Q$m->[1]\E)?|(\Q$m->[2]\E)?(\Q$m->[3]\E)([ \t]*\n?)/;
    my($bd, @body);
    my $lp = 0; #last pos
    while($$sr =~ /$reg/g){
        if($2){ # [%
            next if $bd;
            my($pos, $len) = (pos($$sr), $3 ? length($1.$2.$3) : length($2));
            $bd = [$pos - $len, $pos, $2.($3 || '')]; #begin directive
            next if $bd->[0] <= $lp;
            push @body, \(my $s = substr($$sr, $lp, $bd->[0] - $lp));
            $self->{ln}++ while $s =~ /\r\n?|\n/g;
        }else{ # %]
            my($pos, $len) = (pos($$sr), $4 ? length($4.$5.$6) : length($5.$6));
            my $ed = [$pos - $len, $4 ? $pos : ($pos - length($6)), ($4 || '').$5];
            if(!$bd){
                $self->{ln}++ while substr($$sr, $lp, $ed->[0] - $lp) =~ /\r\n?|\n/g;
                $self->raise(qq{No "$m->[0]"});
            }
            push @body, $self->create_directive($sr, $bd, $ed, int @body, $self->{ln});
            $self->{ln}++ while substr($$sr, $bd->[0], $ed->[1] - $bd->[0]) =~ /\r\n?|\n/g;
            $lp = $ed->[1];
            $bd = $ed = undef;
        }
    }
    $self->raise(qq{No "$m->[3]" after "$bd->[2]"}) if $bd;
    if(my $s = $self->{stack}[-1]){
        $self->raise('No "END" directive', $s->[0]);
    }
    push @body, \(my $s = substr($$sr, $lp)) if length($$sr) > $lp;
    \@body;
}

sub raise {
    my($self, $msg, $dtv) = @_;
    die $msg = (defined $msg ? $msg : $self->{error})."\n at ".($dtv ? $dtv->head : '').
        '('.($self->{path} || '?').' '.(($dtv || $self)->{ln}).")\n";
}

sub reduce_cache {
    my $self = shift;
    warn 'Cache reduced from '.(int keys %{$self->{cache}}).' to '.$self->_reduce_cache(@_);
}

sub _reduce_cache {
    my $self = shift;
    my $cache = $self->{cache};
    my $cnt = keys %$cache;
    my $half = int($cnt / 2);
    my %c2k;
    while(my($k, $v) = each %$cache){
        push @{$c2k{$v->[0]} ||= []}, $k;
    }
    foreach(sort{ $a <=> $b } keys %c2k){
        delete $cache->{$_} for @{$c2k{$_}};
        last if ($cnt -= @{$c2k{$_}}) < $half;
    }
    $_->[0] = 0 for values %$cache;
    $cnt;
}

1;
